home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / tcl / tcl70b2.lha / tcl7.0b2 / tests / defs < prev    next >
Text File  |  1991-12-05  |  2KB  |  73 lines
  1. # This file contains support code for the Tcl test suite.  It is
  2. # normally sourced by the individual files in the test suite before
  3. # they run their tests.  This improved approach to testing was designed
  4. # and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
  5.  
  6. set VERBOSE 0
  7. set TESTS {}
  8. set auto_noexec 1
  9. set auto_noload 1
  10. catch {rename unknown ""}
  11.  
  12. # If tests are being run as root, issue a warning message and set a
  13. # variable to prevent some tests from running at all.
  14.  
  15. set user {}
  16. catch {set user [exec whoami]}
  17. if {$user == "root"} {
  18.     puts stdout "Warning: you're executing as root.  I'll have to"
  19.     puts stdout "skip some of the tests, since they'll fail as root."
  20. }
  21.  
  22. # Some of the tests don't work on some system configurations due to
  23. # configuration quirks, not due to Tcl problems;  in order to prevent
  24. # false alarms, these tests are only run in the master source directory
  25. # at Berkeley.  The presence of a file "Berkeley" in this directory is
  26. # used to indicate that these tests should be run.
  27.  
  28. set atBerkeley [file exists Berkeley]
  29.  
  30. proc print_verbose {test_name test_description contents_of_test answer} {
  31.     puts stdout "\n"
  32.     puts stdout "==== $test_name $test_description"
  33.     puts stdout "==== Contents of test case:"
  34.     puts stdout "$contents_of_test"
  35.     puts stdout "==== Result was:"
  36.     puts stdout "$answer"
  37. }
  38.  
  39. proc test {test_name test_description contents_of_test passing_results} {
  40.     global VERBOSE
  41.     global TESTS
  42.     if {[string compare $TESTS ""] != 0} then {
  43.     set ok 0
  44.     foreach test $TESTS {
  45.         if [string match $test $test_name] then {
  46.         set ok 1
  47.         break
  48.         }
  49.         }
  50.     if !$ok then return
  51.     }
  52.     set answer [uplevel $contents_of_test]
  53.     if {[string compare $answer $passing_results] == 0} then { 
  54.     if $VERBOSE then {
  55.         print_verbose $test_name $test_description $contents_of_test $answer
  56.         puts stdout "++++ $test_name PASSED"
  57.     }
  58.     } else { 
  59.     print_verbose $test_name $test_description $contents_of_test $answer 
  60.     puts stdout "---- Result should have been:"
  61.     puts stdout "$passing_results"
  62.     puts stdout "---- $test_name FAILED" 
  63.     }
  64. }
  65.  
  66. proc dotests {file args} {
  67.     global TESTS
  68.     set savedTests $TESTS
  69.     set TESTS $args
  70.     source $file
  71.     set TESTS $savedTests
  72. }
  73.